(define-library (punctex symbolic)
  (export parse parse-string parse-file)
  (import (scheme base)
          (scheme case-lambda)
          (scheme file)
          (only (srfi 1)
                list-index take drop drop-right
                first second)
          (rename
           (only (srfi 14)
                 char-set:full char-set:whitespace char-set:hex-digit)
           (char-set:full cs:full)
           (char-set:whitespace cs:ws)
           (char-set:hex-digit cs:xd))
          (prefix (packrat) pkr:))
  (cond-expand
   (chibi (import (chibi match)))
   (chicken (import (matchable)))
   (cyclone (import (cyclone match)))
   (gauche (import (util match)))
   (guile (import (ice-9 match)))
   (mosh (import (match)))
   (sagittarius (import (match)))
   (else (import (srfi 204))))
  (begin

    ;; Helpers ;;

    (define-record-type <nil-car>
      (make-nil-car)
      nil-car?)

    (define list-unwrap
      (match-lambda
        (() (make-nil-car))
        ((x) x)))

    ;; XXX: O(m) time?
    (define hierarchize
      (lambda (xs ls) ; len(ls) = len(xs) - 1; ∀ l in ls, l ≥ 0
        (if (null? ls)
            (if (nil-car? (car xs)) (list) xs)
            (hier xs ls))))

    (define hier
      (lambda (xs ls)
        (let ((i (list-index (lambda (l) (= l 0)) ls)))
          (if (not i)
              (list (hier xs (descend ls)))
              (let ((left (hier-left (take xs (+ i 1)) (descend (take ls i))))
                    (right (hier-right (drop xs (+ i 1)) (drop ls (+ i 1)))))
                (if (nil-car? left)
                    right
                    (cons left right)))))))

    (define hier-left
      (lambda (xs ls)
        (if (null? ls)
            (car xs)
            (hier xs ls))))

    (define hier-right
      (lambda (xs ls)
        (if (null? ls)
            xs
            (hier xs ls))))

    (define descend
      (lambda (ls)
        (map (lambda (l) (- l 1)) ls)))

    ;; Nonterminal constructors ;;

    (define sl&cl-ctr
      (match-lambda
        ((_ x0? n0 ((x1s n1s) ...) x2? _)
         (hierarchize
          (cons (list-unwrap x0?) (append x1s x2?))
          (drop-right
           (let* ((ns (cons n0 n1s))
                  (n-max (apply max ns)))
             (map (lambda (n) (- n-max n))
                  ns))
           (if (null? x2?) 1 0))))))

    (define digit-seq-ctr
      (match-lambda
        ((d0 ((_ d1s) ...))
         (list->string (cons d0 d1s)))))

    ;; Grammar ;;

    (pkr:define-grammar punctex-grammar
      (doc (~ expr eof)
           first)
      (expr (~ (? ws) (/ sl cp cl wl unit) (? ws))
            second)

      ;; Collections ;;

      (sl (~ (? ws) (? sle) semics (* (~ sle semics)) (? sle) (? ws))
          sl&cl-ctr)
      (semics (+ semic)
              length)
      (sle (/ cp cl wl unit))

      (cp (~ (? ws) cpe0 colon cpe (? ws))
          (match-lambda
            ((_ x0 _ x1 _)
             (cons x0 x1))))
      (cpe0 (/ cl wl unit))
      (cpe (/ cp cl wl unit))

      (cl (~ (? ws) (? cle) commas (* (~ cle commas)) (? cle) (? ws))
          sl&cl-ctr)
      (commas (+ comma)
              length)
      (cle (/ wl unit))

      (wl (~ (? ws) unit (+ (~ ws unit)) (? ws))
          (match-lambda
            ((_ x0 ((_ x1s) ...) _)
             (cons x0 x1s))))

      ;; Units ;;

      (unit (/ group sym))

      (group (/ (~ lpar expr rpar)
                (~ lsqr expr rsqr)
                (~ lcur expr rcur))
             second)

      ;;; Symbols ;;;

      (sym (/ quo-sym bare-sym))

      (quo-sym (~ grvact (* (/ sym-esc esc sym-nchar)) grvact)
               second list->string string->symbol)
      (sym-esc (~ revsol grvact)
               second)
      (sym-nchar (& (! grvact) ,cs:full))

      (bare-sym (+ (& (! delim) (! cmt-delim) ,cs:full))
                list->string string->symbol)
      (delim (/ grvact
                lpar rpar lsqr rsqr lcur rcur
                comma colon semic
                ws))

      ;; General escapes ;;

      ;; TODO: linebreak escape
      (esc (/ cmn-esc u-esc))
      (cmn-esc (~ revsol (/ #\\ #\a #\b #\d #\e #\t #\n #\r #\0))
               (match-lambda
                 ((_ #\\) #\\)
                 ((_ #\a) #\alarm)
                 ((_ #\b) #\backspace)
                 ((_ #\d) #\delete)
                 ((_ #\e) #\escape)
                 ((_ #\t) #\tab)
                 ((_ #\n) #\newline)
                 ((_ #\r) #\return)
                 ((_ #\0) #\null)))
      (u-esc (~ revsol #\u
                (/ (~ lpar (? ws) x-seq (? ws) rpar)
                   (~ lsqr (? ws) x-seq (? ws) rsqr)
                   (~ lcur (? ws) x-seq (? ws) rcur)))
             (match-lambda
               ((_ _ (_ _ x _ _))
                (let ((y (string->number x #x10)))
                  (if (or (<= y #xd7ff) (and (>= y #xe000) (<= y #x10ffff)))
                      (integer->char y)
                      (error "invalid Unicode hex scalar value" y))))))

      (x-seq (~ ,cs:xd (* (~ (? lowline) ,cs:xd)))
             digit-seq-ctr)
      (lowline #\_)

      ;; Punctuation marks ;;

      (grvact #\x60)
      (lpar #\x28)
      (rpar #\x29)
      (lsqr #\x5b)
      (rsqr #\x5d)
      (lcur #\x7b)
      (rcur #\x7d)
      (comma (~ (? ws) #\, (? ws)))
      (colon (~ (? ws) #\: (? ws)))
      (semic (~ (? ws) #\; (? ws)))

      (ws (+ (/ cmt ,cs:ws)))

      ;; Comments ;;

      (cmt (/ (~ numsig lpar (* (/ cmt-esc cmt-nchar cmt)) rpar numsig)
              (~ numsig lsqr (* (/ cmt-esc cmt-nchar cmt)) rsqr numsig)
              (~ numsig lcur (* (/ cmt-esc cmt-nchar cmt)) rcur numsig)))
      (cmt-esc (~ revsol cmt-delim))
      (cmt-nchar (& (! cmt-delim) ,cs:full))
      (cmt-delim (/ (~ numsig lpar) (~ rpar numsig)
                    (~ numsig lsqr) (~ rsqr numsig)
                    (~ numsig lcur) (~ rcur numsig)))
      (numsig #\#)

      ;; Other syntactic characters ;;

      (revsol #\\)

      (eof ,eof-object?)
    )

    ;; Parser ;;

    (define parse
      (case-lambda
        (()
         (pkr:parse punctex-grammar read-char (current-input-port) 'doc))
        ((p)
         (parameterize ((current-input-port p))
           (parse)))))

    (define parse-string
      (lambda (str)
        (call-with-port (open-input-string str) parse)))

    (define parse-file
      (lambda (path)
        (call-with-input-file path parse)))
  )
)
